Visual Basic Controls/Visual Basic Controls.iso/vbcontrol/sgwnd10/clstring.bas

BASIC Source File | 1998-06-03 | 14.0 KB | 427 lines

Attribute VB_Name = "VBString"
'String manipulation routines
'Doesn't require other modul
'Versoin 4.0.0 updated 26.09.1996
'Added 27.09.1996 String_WordWrap,FindStringInString removed,CampareStrings removed
Option Explicit

Private Declare Function lstrcmpi Lib "kernel32" Alias "lstrcmpiA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long

' For String_Align
Private Const N_FMT_LEFT = 0
Private Const N_FMT_CENTER = 1
Private Const N_FMT_RIGHT = 2

Private Const S_TAG_DELIMITER = ";"  ' Tag delimiter string
' Tag substring Ids
Private Const S_TID_LOOKUP = "LK"
Private Const S_TID_ID = "ID"
Private Const S_TID_LINKLABEL = "LBLID"
Private Const S_TID_DBFIELD = "DBFLD"
Private Const S_TID_LINKTEXT = "TXTID"

Private Const N_MAX_TEXTLEN = 30720  ' 30K ' Limit for Text property length

Public Function String_Capitalize(ByVal sOrig$) As String
   Dim i%

   If sOrig <> "" Then
       Mid$(sOrig, 1, 1) = UCase$(Mid$(sOrig, 1, 1))
       For i = 1 To Len(sOrig) - 1
         If Mid$(sOrig, i, 2) = vbCrLf Then Mid$(sOrig, i + 2, 1) = UCase$(Mid$(sOrig, i + 2, 1))
         If Mid$(sOrig, i, 1) = " " Then Mid$(sOrig, i + 1, 1) = UCase$(Mid$(sOrig, i + 1, 1))
       Next
   End If

   String_Capitalize = sOrig
End Function


Function String_FindString(ByVal sString As String, sFind As String, sSubDelimiter As String, iStart As Integer, cmp As Integer) As Integer
   Dim RetVal As Integer, n As Integer, i As Integer
   Dim sBuf As String
   On Error GoTo FindStringErr

   RetVal = 0
   n = 1
   Do
      sBuf = String_Parameter(sFind, n, sSubDelimiter)
      If sBuf <> "" Then
         i = InStr(iStart, sString, sBuf, cmp)
         If i > 0 Then
            If i < RetVal Or RetVal = 0 Then RetVal = i
         End If
      End If
      n = n + 1
   Loop While sBuf <> ""
   String_FindString = RetVal

   Exit Function
FindStringErr:
   String_FindString = 0
   Exit Function
End Function
Function String_StripMultipleBlanks(ByVal sOrig As String) As String
   Dim i%, n%, m%

   m = Len(sOrig)  'strip multiple blanks
   n = m - 1
   For i = m To 1 Step -1
      If Mid(sOrig, i, 1) = " " Then
         n = i
         Do
            i = i - 1
            If i > 1 Then
               If Mid(sOrig, i, 1) <> " " Then Exit Do
            End If
         Loop While i > 1
         sOrig = Left(sOrig, i + 1) + Mid(sOrig, n + 1)
      End If
   Next
   String_StripMultipleBlanks = sOrig
End Function

'------------------------------------------------------------------------------------------------
'   Desc: strip a given string of all carriage return and adds new in desired position
'  Given: sString - source string
'         iMaxLen - longest size of single line
'         frm     - form, used for font information
' Global: nil
'Returns: wraped string
'   Note: nil
'   Hist: 27.09.1996 - Goran Borevkovic, created
'-----------------------------------------------------------------------------------------
Public Function String_WordWrap(ByVal sString As String, iMaxLen As Integer, frm As Form) As String
   Dim i As Integer
   Dim sWord As String, sTmpString As String
   Dim sSingleLine As String

   sString = String_Token(sString, Chr(13), Chr(32))
   sString = sString & Chr(32) & "<EndOfString>"

   Do
      i = i + 1
      sWord = String_Parameter(sString, i, Chr(32))
      If frm.TextWidth(sSingleLine) + frm.TextWidth(sTmpString) > iMaxLen Then
         sTmpString = sTmpString & Chr(13) & sWord
         sSingleLine = sWord
      Else
         sTmpString = sTmpString & Chr(32) & sWord
         sSingleLine = sSingleLine & Chr(32) & sWord
      End If
   Loop While sWord <> "<EndOfString>"
   sTmpString = Left$(sTmpString, Len(sTmpString) - 14)
   String_WordWrap = sTmpString
End Function

'------------------------------------------------------------------------------------------------
'   Desc: count characters in string
'  Given: sString - source string
'         sChar - character we want to count
' Global: nil
'Returns: numer of characters in string
'   Note: nil
'   Hist: 27.09.1996 - Goran Borevkovic, created
'-----------------------------------------------------------------------------------------
Public Function String_CharCount(sString As String, sChar As String) As Integer
   Dim iStrPos As Integer
   Dim i As Integer

   iStrPos = InStr(sString, sChar)

   Do While iStrPos > 0
      i = i + 1
      iStrPos = InStr(iStrPos + 1, sString, sChar)
   Loop
   String_CharCount = i
End Function


'------------------------------------------------------------------------------------------------
'   Desc: Formats given string by aligning it in the result string
'  Given: sRaw - string to format
'         nLen - desired length of the result string
'         nAlign - desired alignment
' Return: formatted string
'   Hist: 941011 - B.Spiljak, created
'------------------------------------------------------------------------------------------------
Function String_Align(ByVal sRaw As String, nLen As Integer, nAlign As Integer) As String
   On Error Resume Next

   Dim sFmt As String
   Dim n As Integer

   n = Len(sRaw)

   Select Case nAlign
      Case N_FMT_LEFT
         If nLen < n Then
            sFmt = Left$(sRaw, nLen)
         Else
            sFmt = sRaw + Space$(nLen - n)
         End If
      Case N_FMT_CENTER
         If nLen < n Then
            sFmt = Mid$(sRaw, (n - nLen) / 2)
            sFmt = Left$(sRaw, nLen)
         Else
            sFmt = Space$((n - nLen) / 2) + sRaw
            sFmt = sFmt + Space$(nLen - Len(sFmt))
         End If
      Case N_FMT_RIGHT
         If nLen < n Then
            sFmt = Right$(sRaw, nLen)
         Else
            sFmt = Space$(nLen - n) + sRaw
         End If
   End Select
   String_Align = sFmt
End Function

'------------------------------------------------------------------------------------------------
'   Desc: returns the requested parameter from the source string
'  Given: sString - source string
'         iParameter - parameter position, 1 -> X
'         sDelimeter - parameter delimiter string
' Global: nil
'Returns: requested parameter or null if not found or error
'   Note: nil
'   Hist: 930907 - R.Parlee, created
'         940218 - R.Parlee, fixed bug, now retrieves last parameter in string
'         940518 - R.Parlee, added check for iParameter greater than number of parameters
'                  String_Parameter returns null
'------------------------------------------------------------------------------------------------
Function String_Parameter(ByVal sString As String, iParameter As Integer, sDelimiter As String) As String
   Dim iPos As Integer
   Dim i As Integer
   Dim iEnd As Integer
   Dim iLastPos As Integer

   On Error GoTo sParmErr

   If Len(sString) = 0 Then 'exit if nothing to do
      String_Parameter = sString
      Exit Function
   End If
   'sString = Trim(sString)
   iPos = 0
   iLastPos = 0
   For i = 1 To iParameter - 1
      iPos = InStr(iPos + 1, sString, sDelimiter)
      If iPos < iLastPos Then
         String_Parameter = ""
         Exit Function
      End If
      iLastPos = iPos
   Next
   iEnd = InStr(iPos + 1, sString, sDelimiter)
   If (iPos = 0) And iParameter > 1 Then
      String_Parameter = ""
   ElseIf (iPos = 0) And (iEnd = 0) Then
      String_Parameter = sString
   ElseIf (iEnd = 0) Then
      String_Parameter = Mid(sString, iPos + 1, Len(sString) - iPos + 1)
   ElseIf iParameter = 1 Then
      String_Parameter = Left(sString, iEnd - iPos - 1)
   Else
      String_Parameter = Mid(sString, iPos + 1, iEnd - iPos - 1)
   End If
   Exit Function

sParmErr:
   String_Parameter = ""
   Exit Function

End Function
'-------------------------------------------------------------------------------------------------
'   Desc: Extracts value for parameter with given Id
'  Given: sString - taged string
'         sParamId - parameter id
'Returns: if found - target value, empty string otherwise
'   Note: Usually used for control Tag strings
'   Hist: 950320 - B.Spiljak, Created
'-------------------------------------------------------------------------------------------------
Function String_ParameterValue(sString As String, sParamId As String) As String
   Dim sItem As String
   Dim i As Integer

   On Error Resume Next

   String_ParameterValue = ""

   i = 1
   Do
      sItem = LTrim(String_Parameter(sString, i, S_TAG_DELIMITER))
      If sItem <> "" Then
         If Left(sItem, Len(sParamId)) = sParamId Then Exit Do
      End If
      i = i + 1
   Loop Until sItem = ""

   If sItem <> "" Then
      i = InStr(sItem, "=")
      If i > 0 Then String_ParameterValue = Trim(Mid(sItem, i + 1))
   End If
End Function

'------------------------------------------------------------------------------------------------
'   Desc: reverse the character order of a given string
'  Given: sOrig - string to reverse
' Global: nil
'Returns: String_Reverse - sOrig in reverse order
'   Note: nil
'   Hist: 930907 - R.Parlee, created
'------------------------------------------------------------------------------------------------
Function String_Reverse(sOrig As String) As String
   Dim sNew As String
   Dim i As Integer

   On Error Resume Next

   For i = Len(sOrig) To 1 Step -1
      sNew = sNew + Mid(sOrig, i, 1)
   Next
   String_Reverse = sNew
End Function

'------------------------------------------------------------------------------------------------
'   Desc: removes a given character from a string
'  Given: sOrig - copy of original string
'         sChar - character to remove
' Global: nil
'Returns: original string without the given character
'  Calls: nil
'   Note:
'   Hist: 930831 - R.Parlee, created
'------------------------------------------------------------------------------------------------
Function String_StripChar(ByVal sOrig As String, sChar As String) As String
   Dim Pos As Integer
   Dim iLen As Integer

   On Error Resume Next

   iLen = Len(sOrig)
   If iLen > 0 Then
      Pos = InStr(sOrig, sChar)
      Do While (Pos > 0)
         If (Pos <= iLen) Then
            sOrig = Left$(sOrig, Pos - 1) + Right$(sOrig, iLen - Pos)
            iLen = iLen - 1
         End If
         Pos = InStr(sOrig, sChar)
      Loop
   End If
   String_StripChar = sOrig
End Function

'---------------------------------------------------------------------------------------------------
'   Desc: strip a given string of all carriage return, linefeed characters
'  Given: sTemp - copy of string to be stripped
'Returns: sTemp with no crlf
'   Note: nil
'   Hist: 930501 - R.Parlee, created
'         930831 - R.Parlee, adjusted to use stripChar
'---------------------------------------------------------------------------------------------------
Function String_StripCrLf(ByVal sTemp As String) As String

   On Error Resume Next

   sTemp = String_StripChar(sTemp, Chr$(13))
   sTemp = String_StripChar(sTemp, Chr$(10))
   String_StripCrLf = sTemp
End Function
Function String_StripBlanks(ByVal sTemp As String) As String

   On Error Resume Next

   sTemp = String_StripNonAscii(sTemp, False)

   sTemp = String_StripChar(sTemp, Chr$(8))
   sTemp = String_StripChar(sTemp, Chr$(9))
   sTemp = String_StripChar(sTemp, Chr$(13))
   sTemp = String_StripChar(sTemp, Chr$(10))
   String_StripBlanks = Trim$(sTemp)
End Function

'---------------------------------------------------------------------------------------------------
'   Desc: remove all non ascii characters from a given string
'  Given: string, bPad - determines whether to replace removed chars with spaces
' Return:
'   Note:
'---------------------------------------------------------------------------------------------------
Function String_StripNonAscii(ByVal sOrig As String, bPad As Integer) As String
   Dim i As Integer
   Dim sTemp As String

   On Error Resume Next

   For i = 1 To Len(sOrig)
      If Asc(Mid(sOrig, i, 1)) < 32 Or Asc(Mid(sOrig, i, 1)) > 126 Then
         If bPad Then sTemp = sTemp + " "
      Else
         sTemp = sTemp + Mid(sOrig, i, 1)
      End If
   Next
   String_StripNonAscii = sTemp
End Function

'------------------------------------------------------------------------------------------------
'   Desc: Converts VB String to C-style string (null-terminated)
'  Given: strVB - VB string
' Return: converted string
'   Note: returns original string on error
'   Hist: 941116 - B.Spiljak, created
'------------------------------------------------------------------------------------------------
Function String_ToCStyle(strVB As String) As String
   On Error GoTo cStylErr:

   Dim n As Integer

   n = InStr(strVB, Chr$(0))
   String_ToCStyle = IIf(n > 0, Left$(strVB, n), strVB + Chr$(0))
   Exit Function
cStylErr:
   String_ToCStyle = strVB
   Exit Function
End Function

' Replace all occurences of sToken with sReplacement in the sOrig string
'
Function String_Token(sOrig As String, sToken As String, sReplacement As String) As String
   Dim iPos As Integer
   Dim sLocal As String
   Dim sRet As String

   iPos = -1
   sLocal = sOrig
   sRet = ""
   Do
      iPos = InStr(sLocal, sToken)
      If iPos > 0 Then
         sRet = sRet & Left(sLocal, iPos - 1) & sReplacement
         sLocal = Mid(sLocal, iPos + Len(sToken))
      End If
   Loop While iPos > 0
   sRet = sRet & sLocal
   String_Token = sRet
End Function

'------------------------------------------------------------------------------------------------
'   Desc: Converts C-style string (null-terminated) to VB string
'  Given: strC - C-style string
' Return: converted string
'   Note: returns original string on error
'   Hist: 941116 - B.Spiljak, created
'------------------------------------------------------------------------------------------------
Function String_ToVBStyle(strC As String) As String
   On Error GoTo vStylErr
   String_ToVBStyle = Left$(strC, InStr(strC, Chr$(0)) - 1)
   Exit Function

vStylErr:
   String_ToVBStyle = strC
   Exit Function

End Function